perm filename STEP.18[AID,LSP] blob
sn#641898 filedate 1982-02-17 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00005 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SINGLE STEPPING PACKAGE INCLUDING STEP & BREAKIF.
C00008 00003 (MACRODEF %DEFAULT (ARGS)
C00014 00004 (DEFUN %MACRO-REPLACE (FORM)
C00024 00005 ASKS WHETHER A DEMON SHOULD BE REMOVED FROM THE LIST.
C00026 ENDMK
C⊗;
;;; SINGLE STEPPING PACKAGE INCLUDING STEP & BREAKIF.
;;;
;;; (STEP) ENABLE ONLY
;;; (STEP T) BEGIN SINGLE STEPPING IMMEDIATELY
;;; (STEP NIL) DISABLE SINGLE STEPPER (I.E. EVALHOOK <= NIL)
;;; (STEP <CLAUSE1> <CLAUSE2> ...)
;;; CLAUSES:
;;; (WHEREIN FN1 FN2 ...) SINGLE STEP WITHIN EVALUATION OF FUNCTIONS FN1, FN2, ETC.
;;; (AFTER FN1 FN2 ...) SINGLE STEP AFTER BEGINNING EVALUATION OF FN1, FN2, ETC.
;;; (BREAKIF P1 P2 ...) BREAK IF ANY OF PREDICATES P1, P2, ETC. IS EVER TRUE.
;;; (STEP *) USE PREVIOUS WHEREIN AFTER AND BREAKIF CLAUSES
;;;
;;; N.B.: A ↑G TURNS THE SINGLE-STEPPER OFF.
;;;
;;; [IFN FOO ...]
;;; [IFN (FOO BAR QUUX ....) ...]
;;; [IFN ((PRED FOO) ...) ..] such as
;;; [IFN ((NOT SAIL) DEC10) ...]
(DECLARE (SPECIAL SI:ECALLEDP))
(COND ((NOT (BOUNDP 'SI:ECALLEDP))
(SETQ SI:ECALLEDP ())))
(DECLARE (EVAL (READ)))
(SETSYNTAX '/[ 'SPLICING ;CONDITIONAL ASSEMBLY HACK
(FUNCTION (LAMBDA NIL ;LOOK SORT OF LIKE MIDAS IF'S
((LAMBDA (IF FLAG R)
(COND ((ATOM FLAG)(SETQ FLAG (NCONS FLAG))))
(COND ((EQ IF 'IFE))
((EQ IF 'IFN) (SETQ IF NIL))
((EQ IF 'IFP) (SETQ IF (EVAL FLAG) FLAG NIL))
((BREAK LOSING-IF T)))
(OR (APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (Q)
(COND ((ATOM Q)
(COND ((MEMQ Q R) T)))
(T (COND ((APPLY (CAR Q)
(NCONS (MEMQ (CADR Q) R))) T))))))
FLAG))
(SETQ IF (NOT IF)))
(AND IF (DO ((Z (TYIPEEK) (TYIPEEK)) (N 1))
((ZEROP N))
(COND ((= Z '133) (SETQ N (1+ N)))
((= Z '135) (SETQ N (1- N))))(TYI))))
(READ) (READ)(STATUS FEATURES))
NIL)))
(DECLARE (EVAL (READ)))
(SETSYNTAX '/] 'SPLICING (FUNCTION (LAMBDA NIL NIL))) ;RIGHT BRACE
(DECLARE (*LEXPR P Q)
(*EXPR EM:REAL-TERPRI)
(*FEXPR STEP BREAKIF)
(FIXNUM INT-STEP-PL INT-STEP-PD STEP-PL STEP-PD STEPLEVEL)
(SPECIAL STEPLEVEL ENABLE-ONLY? GLOBALSTEP? LOCALSTEP? FLUSHSTEP?
STEPPING? DEMONS? STEPDEMONS STEPWHEREIN CHECKING? %CE
MACROSTEP? %value -em:ecalledp- -em:mode-
STEPAFTER STEP-PL STEP-PD))
(cond ((boundp '-em:ecalledp-))
(t (setq -em:ecalledp- ())))
(OR (GETL 'P '(EXPR LSUBR))
[IFN SAIL (AND (DEFPROP Q (P FAS DSK (MAC LSP)) AUTOLOAD)
(DEFPROP P (P FAS DSK (MAC LSP)) AUTOLOAD))]
[IFN ((NOT SAIL) DEC10) (AND (DEFPROP Q (P FAS SYS (/1 /2)) AUTOLOAD)
(DEFPROP P (P FAS SYS (/1 /2)) AUTOLOAD))])
;;; PRINLEVEL AND PRINDEPTH FOR STEP. THESE CAN BE RANDOMLY SET.
(SETQ STEP-PL 4. STEP-PD 3.)
;;; These macro definitions require the file MACROD.>[AID,RPG] which
;;; is known to SAIL Maclisp.
[IFN SAIL
(MACRODEF TERMINAL-READCH ()
((LAMBDA(↑Q ↑R ↑W)
(PROG2 () (TYI) (AND -EM:ECALLEDP- (EQ -EM:MODE- 'LTYPE)
(EM:REAL-TERPRI)))) NIL NIL NIL))]
[IFN ((NOT SAIL) DEC10)
(MACRODEF TERMINAL-READCH ()
((LAMBDA(↑Q ↑R ↑W X)
(SSTATUS LINMODE NIL)
(PROG2 NIL (READCH)(SSTATUS LINMODE X))) NIL NIL NIL (STATUS LINMODE)))]
(MACRODEF TERMINAL-PRINC (X)
((LAMBDA(↑R ↑W PRINLENGTH PRINLEVEL)
(PRINC X)) NIL NIL STEP-PL STEP-PD))
(MACRODEF TERMINAL-NEWLINE ()
((LAMBDA (↑R ↑W)
(TERPRI)) NIL NIL))
(MACRODEF TERMINAL-TYO (X)
((LAMBDA (↑R ↑W) (TYO X)) NIL NIL))
;(MACRODEF PROG1 X (PROG2 NIL . X))
(MACRODEF %DEFAULT (ARGS)
(COND ((AND ARGS
((LAMBDA (CARGS)
(AND
(NOT (EQ CARGS T))
(NOT (EQ CARGS '*))
(NOT (EQ CARGS NIL))
(OR (ATOM CARGS)
((LAMBDA (CAARGS)
(AND
(NOT (EQ CAARGS 'WHEREIN))
(NOT (EQ CAARGS 'AFTER))
(NOT (EQ CAARGS 'BREAKIF))))
(CAR CARGS)))))
(CAR ARGS)))
(SETQ ARGS (NCONS (CONS 'WHEREIN ARGS))) ) ))
(DEFUN STEP-HARD FEXPR (ARGS)
(%DEFAULT ARGS)
(SETQ CHECKING? T)
(%%STEP1%% ARGS))
(DEFUN E-STEP FEXPR (ARGS)
((LAMBDA (ARGS)
(%DEFAULT ARGS)
(%%STEP1%% ARGS)) (NCONS (CAAR ARGS)))
(HOOKER (CAR ARGS)))
(DEFUN UNSTEP FEXPR (ARGS)
(COND (ARGS (%DEFAULT ARGS))
(T (SETQ ARGS (NCONS (CONS 'WHEREIN STEPWHEREIN)))))
(UNSTEP1 ARGS))
(DEFUN UNSTEP1 (ARGS)
(MAPC (FUNCTION (LAMBDA (Q) (SETQ STEPWHEREIN (DELQ Q STEPWHEREIN))))
(CDR (ASSQ 'WHEREIN ARGS)))
(MAPC (FUNCTION (LAMBDA (Q) (SETQ STEPAFTER (DELQ Q STEPAFTER))))
(CDR (ASSQ 'WHEREIN ARGS))))
(DEFUN STEP FEXPR (ARGS)
(%DEFAULT ARGS)
(SETQ CHECKING? NIL)
(%%STEP1%% ARGS))
(DEFUN %%STEP1%% (ARGS)
(SETQ DEMONS? NIL
; ENABLE-ONLY? NIL
GLOBALSTEP? NIL
MACROSTEP? NIL
FLUSHSTEP? NIL
LOCALSTEP? NIL
STEPLEVEL 0.
*RSET T)
(SSTATUS UUOLINKS)
(PROG2
(SETQ STEPPING? T)
(COND ((EQ (CAR ARGS) '*)
(LIST (CONS 'AFTER STEPAFTER)
(CONS 'WHEREIN STEPWHEREIN)
(CONS 'BREAKIF STEPDEMONS)))
(T ARGS))
(COND ((NULL ARGS) ;(SETQ ENABLE-ONLY? T)
(setq evalhook 'hooker))
((EQ (CAR ARGS) '*)
(SETQ DEMONS? STEPDEMONS EVALHOOK 'HOOKER))
((EQ (CAR ARGS) 'T)
(SETQ GLOBALSTEP? T EVALHOOK 'HOOKER))
((EQUAL ARGS '(NIL))
(SETQ *RSET NIL EVALHOOK NIL STEPPING? NIL))
(T (SETQ STEPDEMONS
(SETQ DEMONS? (CDR (ASSOC 'BREAKIF
ARGS)))
STEPAFTER
(CDR (ASSOC 'AFTER ARGS))
STEPWHEREIN
(CDR (ASSOC 'WHEREIN ARGS))
EVALHOOK
'HOOKER))) ))
;;; THE EVALFRAME FUNCTION.
(DEFUN HOOKER (FORM)
(COND (FLUSHSTEP? (setq %value (EVALHOOK FORM 'HOOKER)))
(T
((LAMBDA (NOT-ATOMP?)
(COND ;(enable-only? (evalhook form nil))
((AND DEMONS? (RUNSTEPDEMONS)))
(GLOBALSTEP? (HOOK1 FORM))
((AND NOT-ATOMP? (MEMQ (CAR FORM) STEPAFTER))
(SETQ GLOBALSTEP? T)
(HOOK1 FORM))
(LOCALSTEP? (HOOK1 FORM))
((AND NOT-ATOMP? (MEMQ (CAR FORM) STEPWHEREIN))
((LAMBDA (LOCALSTEP?) (PROG1 (HOOK1 FORM)(TERMINAL-NEWLINE))) T))
(((lambda (q)
(cond (q
((LAMBDA (LOCALSTEP?)
(hookprint '|<in |)
(terminal-princ q)
(terminal-princ '|>|)
(PROG1 (HOOK1 FORM)(TERMINAL-NEWLINE))) T))))
(and not-atomp? checking? (wherein))))
((setq %value (EVALHOOK FORM 'HOOKER))))) (NOT (ATOM FORM))))))
(defun wherein ()
(*catch 'OUT
(progn
((lambda (q)
(cond ((memq q stepwherein)
(*throw 'out q))))
(do ((i (baklist)(cdr i)))
((and (not (sysp (caar i)))
(not (memq (caar i) '(wherein hooker hook1))))(caar i))))
nil)))
;;; PRINTS OUT THE FORM.
;;; INPUT FROM TTY DETERMINES WHETER OR NOT TO CONTINUE SINGLE STEPPING.
;;; INPUT = ⊗S CONTINUE
;;; ⊗Q QUIT SINGLE STEPPING ALTOGETHER
;;; ⊗X DON'T SINGLE STEP WITHIN THIS FORM (CAN DO (STEP T) LATER)
;;; FOR USE WHEN BREAKPOINTS ARE EXPECTED.
;;; ⊗Z DON'T SINGLE STEP WITHIN THIS FORM (CANNOT DO (STEP T) LATER)
;;; ⊗C CONTINUE, BUT KEEP THE CURRENT DEMONS, ETC, VALID
;;; ⊗V SAME AS ⊗X BUT SETS *RSET TO NIL
;;; ⊗B BREAKS AT CURRENT POSITION
;;; ⊗P RE-PRINTS THE FORM
;;;
(DEFUN %MACRO-REPLACE (FORM)
((LAMBDA (FUN)
(COND (FUN
((LAMBDA (X)
(COND (X (SUBRCALL NIL X FORM))
(T (PROGV (CADR FUN)
(NCONS FORM)
(EVAL (CONS 'PROGN
(CDDR FUN)))))))
(GET FUN 'SUBR)))
(T (SETQ STEPLEVEL (1- STEPLEVEL))
FORM)))
(GET (CAR FORM) 'MACRO)))
(DEFUN HOOK1 (FORM)
(HOOKPRINT (SETQ %CE FORM))
(COND ((OR (ATOM FORM) (MEMQ (CAR FORM) '(STORE
QUOTE
FUNCTION
COMMENT
DECLARE)))
(TERMINAL-PRINC '| = |)
((LAMBDA (FORM) (TERMINAL-PRINC FORM) FORM) (setq %value (EVALHOOK FORM NIL))))
((MEMQ (CAR FORM) '(STEP BREAKIF))
(COND ((TRACED? (CAR FORM))
((LAMBDA (↑R ↑W) (TERMINAL-NEWLINE)
(TERMINAL-PRINC '|...untracing |)
(TERMINAL-PRINC (CAR FORM))
(TERMINAL-PRINC '|...|)
(TERMINAL-NEWLINE))
NIL NIL)
(APPLY 'UNTRACE (NCONS (CAR FORM)))))
(setq %value (EVALHOOK FORM NIL)))
(T (SETQ STEPLEVEL (1+ STEPLEVEL))
(SETQ FORM ((LAMBDA (LOCALSTEP? GLOBALSTEP? *RSET)
((LAMBDA (RESULT)
(COND (MACROSTEP?
(SETQ MACROSTEP? NIL
FORM (%MACRO-REPLACE FORM))
(HOOK1 FORM))
(T (setq %value (EVALHOOK FORM RESULT)))) )
(CONTINUE-STEPPING? FORM)))
LOCALSTEP? GLOBALSTEP? *RSET))
(SETQ STEPLEVEL (1- STEPLEVEL))
(HOOKPRINT FORM))))
;;; READS CHARACTER FROM TTY AND RETURNS NEXT HOOK-FUNCTION
(DECLARE (SPECIAL %%STEP-THROUGH%% %%STOP-STEP%% %%STEP-OVER%% %%STEP-INTO%%
%%RE-PRINT-PRETTY%% %%RE-PRINT%% %%IGNORE%%))
[IFN SAIL
; ⊗B
(defun %%break%% macro (x) (list
'quote
(LIST 66. 98. 450. 482.
456. 488. ;226. 194. 200. 232.
)))
(defun %%quit-chars%% macro (x) (list 'quote (list 455. 487. 231. 199.)))
(DEFUN %%IGNORE%% MACRO (X) (LIST 'QUOTE (LIST 10. 13.)))
;⊗M
(DEFUN %%step-over-macro%% macro (x) (LIST 'QUOTE (LIST 461. 237. 493. 365. 205. 333.)))
; ⊗S
(DEFUN
%%STEP-THROUGH%% MACRO (X) (LIST 'QUOTE (LIST 467. 211. 339. 499. 243. 371.)))
; ⊗V
(DEFUN
%%STEP-RSET%% MACRO (X) (LIST 'QUOTE (LIST 470. 502. 246. 374. 214. 342.)))
; ⊗Q
(DEFUN
%%STOP-STEP%% MACRO (X)(LIST 'QUOTE (LIST 465. 497. 241. 369. 337.)))
; ⊗X
(DEFUN
%%STEP-OVER-WITH-CONTINUE%% MACRO (X)(LIST 'QUOTE (LIST 472. 344. 504. 248. 376.)))
; ⊗Z
(DEFUN
%%STEP-OVER%% MACRO (X)(LIST 'QUOTE (LIST 474. 346. 506. 250. 378.)))
; ⊗C
(DEFUN
%%STEP-INTO%% MACRO (X)(LIST 'QUOTE (LIST 451. 227. 355. 483. 195. 323.)))
; ⊗P
(DEFUN %%RE-PRINT-PRETTY%% MACRO (X) (LIST 'QUOTE (LIST 496. 464.)))
; αP
(DEFUN %%RE-PRINT%% MACRO (X) (LIST 'QUOTE (LIST 208. 368. 336. 240. 200. 194.)))]
[IFN ((NOT SAIL) DEC10)
(defun %%break%% macro (x) (list 'quote (list (ascii 66.)(ascii 98.))))
(DEFUN %%IGNORE%% macro(X) (LIST 'QUOTE (LIST (ASCII 10.)(ASCII 13.))))
(DEFUN %%STEP-OVER-MACRO%% (X)(LIST 'QUOTE (LIST (ASCII 77.) (ascii 109.))))
(DEFUN
%%STEP-THROUGH%% MACRO (X) (LIST 'QUOTE (LIST (ASCII 83.)(ASCII 115.))))
(DEFUN
%%STOP-STEP%% MACRO (X)(LIST 'QUOTE (LIST (ASCII 81.)(ASCII 113.))))
(DEFUN
%%STEP-RSET%% MACRO (X)(LIST 'QUOTE (LIST (ASCII 86.)(ASCII 118.))))
(DEFUN
%%STEP-OVER-WITH-CONTINUE%% MACRO (X)(LIST 'QUOTE (LIST (ASCII 88.)(ASCII 120.))))
(DEFUN
%%STEP-OVER%% MACRO (X)(LIST 'QUOTE (LIST (ASCII 90.)(ASCII 122.))))
(DEFUN
%%STEP-INTO%% MACRO (X)(LIST 'QUOTE (LIST (ASCII 67.)(ASCII 99.))))
(DEFUN %%RE-PRINT%% macro (X) (LIST 'QUOTE (LIST (ASCII 80.)(ASCII 112.))))
(DEFUN %%RE-PRINT-PRETTY%% macro (X) NIL)]
(DEFUN CONTINUE-STEPPING? (FORM)
(PROG (CH ↑Q INT-STEP-PL INT-STEP-PD)
(SETQ INT-STEP-PL STEP-PL INT-STEP-PD STEP-PD)
LOOP (SETQ CH (TERMINAL-READCH))
(AND SI:ECALLEDP (TERPRI))
(COND ((MEMBER CH (%%RE-PRINT%%))
(SETQ INT-STEP-PL (1+ INT-STEP-PL) INT-STEP-PD (1+ INT-STEP-PD))
((LAMBDA (STEP-PD STEP-PL STEPLEVEL) (HOOKPRINT FORM))
INT-STEP-PD INT-STEP-PL (1- STEPLEVEL))
(GO LOOP))
((MEMBER CH (%%RE-PRINT-PRETTY%%))(SPRINTER FORM)(GO LOOP))
(T (SETQ INT-STEP-PL STEP-PL INT-STEP-PD STEP-PD)))
(COND ((MEMBER CH (%%IGNORE%%))
(GO LOOP))
((MEMBER CH (%%STEP-THROUGH%%))
(COND ((TRACED? (CAR FORM))
((LAMBDA (↑R ↑W) (TERMINAL-NEWLINE)
(TERMINAL-PRINC '|...untracing |)
(TERMINAL-PRINC (CAR FORM))
(TERMINAL-PRINC '|...|)
(TERMINAL-NEWLINE))
NIL NIL)
(APPLY 'UNTRACE (NCONS (CAR FORM)))))
(RETURN 'HOOKER))
((MEMBER CH (%%STOP-STEP%%))
(RETURN (AND (SETQ FLUSHSTEP? T) NIL)))
((MEMBER CH (%%STEP-OVER%%)) (RETURN NIL))
((MEMBER CH (%%STEP-OVER-WITH-CONTINUE%%))
(SETQ LOCALSTEP? NIL GLOBALSTEP? NIL)
(RETURN 'HOOKER))
((MEMBER CH (%%STEP-RSET%%))
(SETQ *RSET NIL LOCALSTEP? NIL GLOBALSTEP? NIL)
(RETURN 'HOOKER))
((MEMBER CH (%%STEP-INTO%%))
(SETQ GLOBALSTEP? NIL)
(RETURN 'HOOKER))
((MEMBER CH (%%STEP-OVER-MACRO%%))
(SETQ MACROSTEP? T)
(RETURN 'HOOKER))
((MEMBER CH (%%BREAK%%)) (BREAK STEP T)
(HOOKPRINT FORM)(GO LOOP))
((MEMBER CH (%%QUIT-CHARS%%))
(↑g))
((TERMINAL-PRINC '| ? |) (GO LOOP)))))
;;; RUNS EACH OF THE PREDICATES IN THE LIST "STEPDEMONS"
;;; UNTIL ON EVALUATES TO NON-NIL OR THE LIST IS EXHAUSTED.
;;; IF ONE IS "TRUE" IT BREAKS.
;;; UPON RETURNING FROM THE BREAK, IT ASKS WHETER THE DEMON SHOULD BE
;;; REMOVED FROM THE LIST.
(DEFUN RUNSTEPDEMONS NIL
(DO ((DEMONS STEPDEMONS (CDR DEMONS)) (VAL))
((NULL DEMONS) NIL)
(SETQ VAL (CAR (ERRSET (EVAL (CAR DEMONS)) NIL)))
(COND (VAL (APPLY 'BREAK
(LIST (LIST 'DEMON:
(CAR DEMONS)
'
VAL)
T))
(KILLSTEPDEMON? (CAR DEMONS))
(RETURN NIL)))))
;;; PRINT OUT THE FORM, WITH PROPER INDENTATION.
(DEFUN HOOKPRINT (FORM)
(TERMINAL-NEWLINE)
((LAMBDA (N)
(DO I 1. (1+ I) (> I (* 2. N)) (TERMINAL-TYO 32.)))
(REMAINDER STEPLEVEL 15.))
((LAMBDA (PRINLENGTH PRINLEVEL) (TERMINAL-PRINC FORM)) STEP-PL STEP-PD)
FORM)
;;; ASKS WHETHER A DEMON SHOULD BE REMOVED FROM THE LIST.
(DEFUN KILLSTEPDEMON? (DEMON)
(AND (Q '(SHOULD I KILL THE STEPPING DEMON:)
(NCONS DEMON)
'?)
(SETQ STEPDEMONS (DELETE DEMON (APPEND STEPDEMONS NIL)))))
;;; SPECIAL FUNCTION FOR CREATING DEMONS
(DEFUN BREAKIF FEXPR (ARGS)
(COND ((NULL (CAR ARGS))
(SETQ DEMONS? NIL)
(AND (EQ EVALHOOK 'DEMONHOOKER)
(SETQ EVALHOOK NIL)))
((EQ (CAR ARGS) T) (SETQ DEMONS? T))
((SETQ DEMONS? T)
(SETQ STEPDEMONS ARGS)
(OR EVALHOOK (SETQ EVALHOOK 'DEMONHOOKER)))))
(DEFUN DEMONHOOKER (FORM)
(COND ((AND DEMONS? (NOT (ATOM FORM)))
(RUNSTEPDEMONS)
(EVALHOOK FORM 'DEMONHOOKER))
(T (EVALHOOK FORM NIL))))
;;; FUNCTION FOR DETERMINING WHETHER OR NOT A FUNCTION IS BEING TRACED
(DEFUN TRACED? (X)
(AND (STATUS FEATURE TRACE)
(GETL 'TRACE '(FEXPR FSUBR LEXPR LSUBR))
(MEMQ X (TRACE))))